Case Study 2

Data import
Check for missing data
Pre-Processing
Exploratory Analysis
Train/Test Split
Linear Model
Naive Bayes

## Loading required package: foreach

## Loading required package: iterators

## Loading required package: parallel

Data import

library(tidyverse)
casedata <- read_csv("CaseStudy2-data.csv")
str(casedata)

Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame':    870 obs. of  36 variables:
 $ ID                      : num  1 2 3 4 5 6 7 8 9 10 ...
 $ Age                     : num  32 40 35 32 24 27 41 37 34 34 ...
 $ Attrition               : chr  "No" "No" "No" "No" ...
 $ BusinessTravel          : chr  "Travel_Rarely" "Travel_Rarely" "Travel_Frequently" "Travel_Rarely" ...
 $ DailyRate               : num  117 1308 200 801 567 ...
 $ Department              : chr  "Sales" "Research & Development" "Research & Development" "Sales" ...
 $ DistanceFromHome        : num  13 14 18 1 2 10 5 10 10 10 ...
 $ Education               : num  4 3 2 4 1 2 5 4 4 4 ...
 $ EducationField          : chr  "Life Sciences" "Medical" "Life Sciences" "Marketing" ...
 $ EmployeeCount           : num  1 1 1 1 1 1 1 1 1 1 ...
 $ EmployeeNumber          : num  859 1128 1412 2016 1646 ...
 $ EnvironmentSatisfaction : num  2 3 3 3 1 4 2 4 3 4 ...
 $ Gender                  : chr  "Male" "Male" "Male" "Female" ...
 $ HourlyRate              : num  73 44 60 48 32 32 90 88 87 92 ...
 $ JobInvolvement          : num  3 2 3 3 3 3 4 2 3 2 ...
 $ JobLevel                : num  2 5 3 3 1 3 1 2 1 2 ...
 $ JobRole                 : chr  "Sales Executive" "Research Director" "Manufacturing Director" "Sales Executive" ...
 $ JobSatisfaction         : num  4 3 4 4 4 1 3 4 3 3 ...
 $ MaritalStatus           : chr  "Divorced" "Single" "Single" "Married" ...
 $ MonthlyIncome           : num  4403 19626 9362 10422 3760 ...
 $ MonthlyRate             : num  9250 17544 19944 24032 17218 ...
 $ NumCompaniesWorked      : num  2 1 2 1 1 1 2 2 1 1 ...
 $ Over18                  : chr  "Y" "Y" "Y" "Y" ...
 $ OverTime                : chr  "No" "No" "No" "No" ...
 $ PercentSalaryHike       : num  11 14 11 19 13 21 12 14 19 14 ...
 $ PerformanceRating       : num  3 3 3 3 3 4 3 3 3 3 ...
 $ RelationshipSatisfaction: num  3 1 3 3 3 3 1 3 4 2 ...
 $ StandardHours           : num  80 80 80 80 80 80 80 80 80 80 ...
 $ StockOptionLevel        : num  1 0 0 2 0 2 0 3 1 1 ...
 $ TotalWorkingYears       : num  8 21 10 14 6 9 7 8 1 8 ...
 $ TrainingTimesLastYear   : num  3 2 2 3 2 4 5 5 2 3 ...
 $ WorkLifeBalance         : num  2 4 3 3 3 2 2 3 3 2 ...
 $ YearsAtCompany          : num  5 20 2 14 6 9 4 1 1 8 ...
 $ YearsInCurrentRole      : num  2 7 2 10 3 7 2 0 1 2 ...
 $ YearsSinceLastPromotion : num  0 4 2 5 1 1 0 0 0 7 ...
 $ YearsWithCurrManager    : num  3 9 2 7 3 7 3 0 0 7 ...
 - attr(*, "spec")=
  .. cols(
  ..   ID = col_double(),
  ..   Age = col_double(),
  ..   Attrition = col_character(),
  ..   BusinessTravel = col_character(),
  ..   DailyRate = col_double(),
  ..   Department = col_character(),
  ..   DistanceFromHome = col_double(),
  ..   Education = col_double(),
  ..   EducationField = col_character(),
  ..   EmployeeCount = col_double(),
  ..   EmployeeNumber = col_double(),
  ..   EnvironmentSatisfaction = col_double(),
  ..   Gender = col_character(),
  ..   HourlyRate = col_double(),
  ..   JobInvolvement = col_double(),
  ..   JobLevel = col_double(),
  ..   JobRole = col_character(),
  ..   JobSatisfaction = col_double(),
  ..   MaritalStatus = col_character(),
  ..   MonthlyIncome = col_double(),
  ..   MonthlyRate = col_double(),
  ..   NumCompaniesWorked = col_double(),
  ..   Over18 = col_character(),
  ..   OverTime = col_character(),
  ..   PercentSalaryHike = col_double(),
  ..   PerformanceRating = col_double(),
  ..   RelationshipSatisfaction = col_double(),
  ..   StandardHours = col_double(),
  ..   StockOptionLevel = col_double(),
  ..   TotalWorkingYears = col_double(),
  ..   TrainingTimesLastYear = col_double(),
  ..   WorkLifeBalance = col_double(),
  ..   YearsAtCompany = col_double(),
  ..   YearsInCurrentRole = col_double(),
  ..   YearsSinceLastPromotion = col_double(),
  ..   YearsWithCurrManager = col_double()
  .. )

The data set has 870 observations and 36 variables for us to work with.

Check for missing data

library(Amelia)
library(naniar)
missmap(casedata, y.at = c(1), y.labels = c(""))

gg_miss_var(casedata, show_pct = TRUE) + labs(title = "Percent Missing by Data Field") + 
    theme(legend.position = "none", plot.title = element_text(hjust = 0.5), 
        axis.title.y = element_text(angle = 0, vjust = 1))

There does not appear to be any missing data in the dataset.

Pre-Processing

Here I am doing some processing of the data. I am going to convert some character columns to factors to make modeling easier.

colsToFactor <- c("Attrition", "BusinessTravel", "Department", "EducationField", 
    "Gender", "JobRole", "MaritalStatus", "Over18", "OverTime", "StockOptionLevel", 
    "JobLevel", "JobInvolvement", "Education", "EnvironmentSatisfaction", "JobSatisfaction", 
    "RelationshipSatisfaction", "WorkLifeBalance", "PerformanceRating")
# Consider 'StockOptionLevel','JobLevel','JobInvolvement','Education'; They
# could be coded as numeric
casedata[, colsToFactor] <- lapply(casedata[, colsToFactor], as.factor)

casedata$logMonthlyIncome <- log(casedata$MonthlyIncome)

casedata$IncomeLt4000 <- ifelse(casedata$MonthlyIncome <= 4000, 1, 0)
casedata$Edu4 <- ifelse(casedata$Education == 4, 1, 0)
casedata$Edu5 <- ifelse(casedata$Education == 5, 1, 0)
casedata$EnvSat1 <- ifelse(casedata$EnvironmentSatisfaction == 1, 1, 0)
casedata$StockOpt0 <- ifelse(casedata$StockOptionLevel == 0, 1, 0)
casedata$StockOpt3 <- ifelse(casedata$StockOptionLevel == 3, 1, 0)
casedata$StockOpt03 <- ifelse(casedata$StockOptionLevel %in% c(0, 3), 1, 0)
casedata$JobLev1 <- ifelse(casedata$JobLevel == 1, 1, 0)
casedata$JobInv1 <- ifelse(casedata$JobInvolvement == 1, 1, 0)
casedata$WorkLife1 <- ifelse(casedata$WorkLifeBalance == 1, 1, 0)
casedata$DistHomeFactor <- as.factor(case_when(casedata$DistanceFromHome <= 
    10 ~ "Close", casedata$DistanceFromHome > 10 & casedata$DistanceFromHome <= 
    20 ~ "Medium", casedata$DistanceFromHome > 20 ~ "Far"))
casedata$HourDay <- casedata$HourlyRate * 8

Exploratory Analysis

Lets start by looking at our dependent variables

Helper Functions

This section is just to create some functions to help with exploratory analysis.

barPlot <- function(df, x) {
    ggplot(df, aes_string(x = x)) + geom_bar()
}

propPlot <- function(df, x, y) {
    ggplot(df, aes_string(x = x, fill = y)) + geom_bar(position = "fill") + 
        scale_y_continuous(labels = scales::percent)
}

fancyTable <- function(df, x) {
    df %>% group_by_at(x) %>% summarise(Count = n(), Proportion = n()/dim(df)[1]) %>% 
        kable() %>% kable_styling(full_width = FALSE)
}

vioPlot <- function(df, x, y) {
    ggplot(df, aes_string(x = x, y = y, fill = x)) + geom_violin() + geom_boxplot(width = 0.2) + 
        stat_summary(fun.y = mean, geom = "point", shape = 5, size = 4, color = "black")
}

histPlot <- function(df, x) {
    ggplot(casedata, aes_string(x)) + geom_histogram(bins = 30)
}

Attrition

fancyTable(casedata, "Attrition")

Attrition	Count	Proportion
No	730	0.8390805
Yes	140	0.1609195

barPlot(casedata, "Attrition")

Out of the 870 employees, 140 left their jobs, which is 16% attrition

Monthly Income

ggplot(casedata, aes(MonthlyIncome)) + geom_histogram(aes(y = ..density..), 
    bins = 30) + stat_function(fun = dnorm, color = "red", args = list(mean = mean(casedata$MonthlyIncome), 
    sd = sd(casedata$MonthlyIncome)))

summary(casedata$MonthlyIncome)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   1081    2840    4946    6390    8182   19999

vioPlot(casedata, x = "Attrition", y = "MonthlyIncome")

We have Monthly Incomes ranging from $1,081 to $19,999. Income is very right skewed, which will effect modeling. We probably want to transform it.

ggplot(casedata, aes(logMonthlyIncome)) + geom_histogram(aes(y = ..density..), 
    bins = 30) + stat_function(fun = dnorm, color = "red", args = list(mean = mean(casedata$logMonthlyIncome), 
    sd = sd(casedata$logMonthlyIncome)))

summary(casedata$logMonthlyIncome)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  6.986   7.951   8.506   8.538   9.010   9.903

The log version of Monthly Income seems more normal but wasn’t as good as I had hoped from the transformation.

Business Travel

fancyTable(casedata, "BusinessTravel")

BusinessTravel	Count	Proportion
Non-Travel	94	0.1080460
Travel_Frequently	158	0.1816092
Travel_Rarely	618	0.7103448

barPlot(casedata, "BusinessTravel")

propPlot(casedata, x = "BusinessTravel", "Attrition")

vioPlot(casedata, x = "BusinessTravel", y = "MonthlyIncome")

681 employees or 71% travel rarely. It seems like the most frequent travelers have the highest attrition rates, and non-travelers have the lowest. Non-travelers have a lower 75th percentile on income, Frequent and non-frequent travelers have similar pay.

Department

fancyTable(casedata, "Department")

Department	Count	Proportion
Human Resources	35	0.0402299
Research & Development	562	0.6459770
Sales	273	0.3137931

barPlot(casedata, "Department")

propPlot(casedata, x = "Department", "Attrition")

vioPlot(casedata, x = "Department", y = "MonthlyIncome")

The sales department has the highest attrition rate and R&D has the lowest attrition rate. Mean income is fairly similar but their is a clear difference in medians with HR having the lowest median pay and Sales having the highest median pay.

Education

fancyTable(casedata, "Education")

Education	Count	Proportion
1	98	0.1126437
2	182	0.2091954
3	324	0.3724138
4	240	0.2758621
5	26	0.0298851

barPlot(casedata, "Education")

propPlot(casedata, x = "Education", "Attrition")

vioPlot(casedata, x = "Education", y = "MonthlyIncome")

Assuming higher values of Education mean more advance education, better educated employees seem to have lower attrtion rates. 1-3 are similar but 4 & 5 have a clear decrease. Education 5 also has a very clear pay advantage.

fancyTable(casedata, "EducationField")

EducationField	Count	Proportion
Human Resources	15	0.0172414
Life Sciences	358	0.4114943
Marketing	100	0.1149425
Medical	270	0.3103448
Other	52	0.0597701
Technical Degree	75	0.0862069

barPlot(casedata, "EducationField")

propPlot(casedata, x = "EducationField", "Attrition")

vioPlot(casedata, x = "EducationField", y = "MonthlyIncome")

Those with education in HR have the highest attrition rates in this sample. Education in Human Resources seems to come with lower median pay, but those educated in marketing have higher median pay

Environment Satisfaction

fancyTable(casedata, "EnvironmentSatisfaction")

EnvironmentSatisfaction	Count	Proportion
1	172	0.1977011
2	178	0.2045977
3	258	0.2965517
4	262	0.3011494

barPlot(casedata, "EnvironmentSatisfaction")

propPlot(casedata, x = "EnvironmentSatisfaction", "Attrition")

vioPlot(casedata, x = "EnvironmentSatisfaction", y = "MonthlyIncome")

Assuming lower is less satisfied, those least satisfied with their enviroment have the highest attrition rates. Mean and Median pay is similar between groups here, but the 75th percentile is lower for groups 2&4. Not sure how this is meaningful to pay overall.

Gender

fancyTable(casedata, "Gender")

Gender	Count	Proportion
Female	354	0.4068966
Male	516	0.5931034

barPlot(casedata, "Gender")

propPlot(casedata, x = "Gender", "Attrition")

vioPlot(casedata, x = "Gender", y = "MonthlyIncome")

Attrition rates are similar between genders, with Men having just a slightly higher rate. In terms of pay, Men are making a little less than average in this sample. Lets look at some other cuts to see if there is any deeper story.

vioPlot(casedata, x = "Gender", y = "MonthlyIncome") + facet_wrap(~Department)

Men have a little better median pay in the Sales department.

vioPlot(casedata, x = "Gender", y = "MonthlyIncome") + facet_wrap(~EducationField)

In terms of mean and median pay, men rarely have an advantage regardless of education field.

JobRole

fancyTable(casedata, "JobRole")

JobRole	Count	Proportion
Healthcare Representative	76	0.0873563
Human Resources	27	0.0310345
Laboratory Technician	153	0.1758621
Manager	51	0.0586207
Manufacturing Director	87	0.1000000
Research Director	51	0.0586207
Research Scientist	172	0.1977011
Sales Executive	200	0.2298851
Sales Representative	53	0.0609195

barPlot(casedata, "JobRole") + theme(axis.text.x = element_text(angle = 90))

propPlot(casedata, x = "JobRole", "Attrition") + theme(axis.text.x = element_text(angle = 90))

vioPlot(casedata, x = "JobRole", y = "MonthlyIncome") + theme(axis.text.x = element_text(angle = 90))

Sales Representatives have the highest attrition rate by far. Managers and Research Directors have the highest pay and low attrition rates.

MaritalStatus

fancyTable(casedata, "MaritalStatus")

MaritalStatus	Count	Proportion
Divorced	191	0.2195402
Married	410	0.4712644
Single	269	0.3091954

barPlot(casedata, "MaritalStatus")

propPlot(casedata, x = "MaritalStatus", "Attrition")

vioPlot(casedata, x = "MaritalStatus", y = "MonthlyIncome")

Single employees have the highest attrition and below average pay.

Over18

fancyTable(casedata, "Over18")

Over18	Count	Proportion
Y	870	1

This seems to be an indicator for the employee being over 18, and 100% of our sample falls into this category. Since there is no variance in this variable it would not be useful for modeling so I am omitting any further analysis.

Over Time

fancyTable(casedata, "OverTime")

OverTime	Count	Proportion
No	618	0.7103448
Yes	252	0.2896552

barPlot(casedata, "OverTime")

propPlot(casedata, x = "OverTime", "Attrition")

vioPlot(casedata, x = "OverTime", y = "MonthlyIncome")

Overtime eligible employees have much higher attrition rates and slightly lower monthly income.

Stock Option Level

fancyTable(casedata, "StockOptionLevel")

StockOptionLevel	Count	Proportion
0	379	0.4356322
1	355	0.4080460
2	81	0.0931034
3	55	0.0632184

barPlot(casedata, "StockOptionLevel")

propPlot(casedata, x = "StockOptionLevel", "Attrition")

vioPlot(casedata, x = "StockOptionLevel", y = "MonthlyIncome")

Most employees fall in Stock Option level 0 or 1, with much fewer in 2 & 3. Stock option levels 0 & 3 have the highest attrition, with 1 & 2 being much lower. Perhaps 1 & 2 have more long term incentives to keep employees at the firm. 1 & 2 also have higher median / average pay.

Job Level

fancyTable(casedata, "JobLevel")

JobLevel	Count	Proportion
1	329	0.3781609
2	312	0.3586207
3	132	0.1517241
4	60	0.0689655
5	37	0.0425287

barPlot(casedata, "JobLevel")

propPlot(casedata, x = "JobLevel", "Attrition")

vioPlot(casedata, x = "JobLevel", y = "MonthlyIncome")

Job level 1 has a much higher attrition rate. Job level also seems very linearly associated with pay.

Job Involvement

fancyTable(casedata, "JobInvolvement")

JobInvolvement	Count	Proportion
1	47	0.0540230
2	228	0.2620690
3	514	0.5908046
4	81	0.0931034

barPlot(casedata, "JobInvolvement")

propPlot(casedata, x = "JobInvolvement", "Attrition")

vioPlot(casedata, x = "JobInvolvement", y = "MonthlyIncome")

Those with lower job involvement have much higher attrition. The relationship with pay is much less clear.

Job Satisfaction

fancyTable(casedata, "JobSatisfaction")

JobSatisfaction	Count	Proportion
1	179	0.2057471
2	166	0.1908046
3	254	0.2919540
4	271	0.3114943

barPlot(casedata, "JobSatisfaction")

propPlot(casedata, x = "JobSatisfaction", "Attrition")

vioPlot(casedata, x = "JobSatisfaction", y = "MonthlyIncome")

Relationship Satisfaction

fancyTable(casedata, "RelationshipSatisfaction")

RelationshipSatisfaction	Count	Proportion
1	174	0.2000000
2	171	0.1965517
3	261	0.3000000
4	264	0.3034483

barPlot(casedata, "RelationshipSatisfaction")

propPlot(casedata, x = "RelationshipSatisfaction", "Attrition")

vioPlot(casedata, x = "RelationshipSatisfaction", y = "MonthlyIncome")

Work Life Balance

fancyTable(casedata, "WorkLifeBalance")

WorkLifeBalance	Count	Proportion
1	48	0.0551724
2	192	0.2206897
3	532	0.6114943
4	98	0.1126437

barPlot(casedata, "WorkLifeBalance")

propPlot(casedata, x = "WorkLifeBalance", "Attrition")

vioPlot(casedata, x = "WorkLifeBalance", y = "MonthlyIncome")

Daily Rate and Hourly Rate

histPlot(casedata, "DailyRate")

summary(casedata$DailyRate)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  103.0   472.5   817.5   815.2  1165.8  1499.0

vioPlot(casedata, x = "Attrition", y = "DailyRate")

ggplot(casedata, aes(x = DailyRate, y = MonthlyIncome)) + geom_point()

I am not seeing any meaningful relationship to attrition or Monthly Income for Daily Rate

histPlot(casedata, "HourlyRate")

summary(casedata$HourlyRate)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  30.00   48.00   66.00   65.61   83.00  100.00

vioPlot(casedata, x = "Attrition", y = "HourlyRate")

ggplot(casedata, aes(x = HourlyRate, y = MonthlyIncome)) + geom_point()

ggplot(casedata, aes(x = HourlyRate, y = DailyRate)) + geom_point()

ggplot(casedata, aes(x = HourlyRate, y = MonthlyRate)) + geom_point()

ggplot(casedata, aes(x = MonthlyIncome, y = MonthlyRate)) + geom_point()

I am not seeing any meaningful relationship to attrition or Monthly Income for Hourly Rate, and Hourly Rate doesn’t seem related to Daily Rate. I would normally assoicate Hourly/Daily rates with income but in this case either this is not true or somehow doesn’t translate to monthly income. I will probably ignore these.

Distance From Home

histPlot(casedata, "DistanceFromHome")

summary(casedata$DistanceFromHome)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  1.000   2.000   7.000   9.339  14.000  29.000

vioPlot(casedata, x = "Attrition", y = "DistanceFromHome")

ggplot(casedata, aes(x = DistanceFromHome, y = MonthlyIncome)) + geom_point()

Distance From Home

fancyTable(casedata, "DistHomeFactor")

DistHomeFactor	Count	Proportion
Close	600	0.6896552
Far	127	0.1459770
Medium	143	0.1643678

barPlot(casedata, "DistHomeFactor")

propPlot(casedata, x = "DistHomeFactor", "Attrition")

vioPlot(casedata, x = "DistHomeFactor", y = "MonthlyIncome")

Those who attrite work farther from home, on average.

Num Companies Worked

histPlot(casedata, "NumCompaniesWorked")

summary(casedata$NumCompaniesWorked)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   1.000   2.000   2.728   4.000   9.000

vioPlot(casedata, x = "Attrition", y = "NumCompaniesWorked")

ggplot(casedata, aes(x = NumCompaniesWorked, y = MonthlyIncome)) + geom_point()

It seems like those that attrite have worked at fewer companies?

Salary Hike

histPlot(casedata, "PercentSalaryHike")

summary(casedata$PercentSalaryHike)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   11.0    12.0    14.0    15.2    18.0    25.0

vioPlot(casedata, x = "Attrition", y = "PercentSalaryHike")

ggplot(casedata, aes(x = PercentSalaryHike, y = MonthlyIncome)) + geom_point()

Performance Rating

fancyTable(casedata, "PerformanceRating")

PerformanceRating	Count	Proportion
3	738	0.8482759
4	132	0.1517241

barPlot(casedata, "PerformanceRating")

propPlot(casedata, x = "PerformanceRating", "Attrition")

vioPlot(casedata, x = "PerformanceRating", y = "MonthlyIncome")

StandardHours

histPlot(casedata, "StandardHours")

summary(casedata$StandardHours)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
     80      80      80      80      80      80

vioPlot(casedata, x = "Attrition", y = "StandardHours")

ggplot(casedata, aes(x = StandardHours, y = MonthlyIncome)) + geom_point()

Age

histPlot(casedata, "Age")

summary(casedata$Age)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  18.00   30.00   35.00   36.83   43.00   60.00

vioPlot(casedata, x = "Attrition", y = "Age")

ggplot(casedata, aes(x = Age, y = MonthlyIncome)) + geom_point()

TotalWorkingYears

histPlot(casedata, "TotalWorkingYears")

summary(casedata$TotalWorkingYears)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   0.00    6.00   10.00   11.05   15.00   40.00

vioPlot(casedata, x = "Attrition", y = "TotalWorkingYears")

ggplot(casedata, aes(x = TotalWorkingYears, y = MonthlyIncome)) + geom_point()

TrainingTimesLastYear

histPlot(casedata, "TrainingTimesLastYear")

summary(casedata$TrainingTimesLastYear)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   2.000   3.000   2.832   3.000   6.000

vioPlot(casedata, x = "Attrition", y = "TrainingTimesLastYear")

ggplot(casedata, aes(x = TrainingTimesLastYear, y = MonthlyIncome)) + geom_point()

YearsAtCompany

histPlot(casedata, "YearsAtCompany")

summary(casedata$YearsAtCompany)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   3.000   5.000   6.962  10.000  40.000

vioPlot(casedata, x = "Attrition", y = "YearsAtCompany")

ggplot(casedata, aes(x = YearsAtCompany, y = MonthlyIncome)) + geom_point()

YearsInCurrentRole

histPlot(casedata, "YearsInCurrentRole")

summary(casedata$YearsInCurrentRole)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   2.000   3.000   4.205   7.000  18.000

vioPlot(casedata, x = "Attrition", y = "YearsInCurrentRole")

ggplot(casedata, aes(x = YearsInCurrentRole, y = MonthlyIncome)) + geom_point()

YearsSinceLastPromotion

histPlot(casedata, "YearsSinceLastPromotion")

summary(casedata$YearsSinceLastPromotion)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   0.000   1.000   2.169   3.000  15.000

vioPlot(casedata, x = "Attrition", y = "YearsSinceLastPromotion")

ggplot(casedata, aes(x = YearsSinceLastPromotion, y = MonthlyIncome)) + geom_point()

YearsWithCurrManager

histPlot(casedata, "YearsWithCurrManager")

summary(casedata$YearsWithCurrManager)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
   0.00    2.00    3.00    4.14    7.00   17.00

vioPlot(casedata, x = "Attrition", y = "YearsWithCurrManager")

ggplot(casedata, aes(x = YearsWithCurrManager, y = MonthlyIncome)) + geom_point()

ID, Employee Number, Employee Count

summary(casedata$EmployeeCount)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
      1       1       1       1       1       1

n_distinct(casedata$ID)

[1] 870

n_distinct(casedata$EmployeeNumber)

[1] 870

These are quick checks to make sure each row represents one employee, and no employees have more than one observation. Employee Count never takes a value other than one, so each row is one employee. ID and Employee number are unique, there are no repeats, so no employee has more than one observation.

Train/Test Split

library(caret)
set.seed(42)
train_ind <- createDataPartition(y = casedata$ID, p = 0.8, list = FALSE)
train.data <- casedata[train_ind, ]
test.data <- casedata[-train_ind, ]

Linear Model

# fit<-lm(data = train, MonthlyIncome ~ ID) broom::tidy(fit)
# RMSE(fit$fitted.values,train$MonthlyIncome) pred <- predict(fit,test)
# RMSE(pred, test$MonthlyIncome)

Naive Bayes

Lets quick try a model with everything in it.

colsToDrop <- c("ID", "EmployeeNumber", "EmployeeCount", "Over18", "StandardHours", 
    "DailyRate", "HourlyRate", "MonthlyRate")
colsToDrop2 <- names(casedata)[c(37:length(casedata))]
nb.train.01 <- train.data %>% select(-c(colsToDrop, colsToDrop2))

trnCtrl <- trainControl(method = "repeatedcv", number = 10, repeats = 5, summaryFunction = twoClassSummary, 
    classProbs = TRUE)

fit.nb <- train(Attrition ~ ., data = nb.train.01, method = "naive_bayes", metric = "Spec", 
    trControl = trnCtrl)
pred <- predict(fit.nb, test.data)

confusionMatrix(pred, test.data$Attrition, positive = "Yes")

Confusion Matrix and Statistics

          Reference
Prediction No Yes
       No  86   6
       Yes 59  21
                                          
               Accuracy : 0.6221          
                 95% CI : (0.5451, 0.6948)
    No Information Rate : 0.843           
    P-Value [Acc > NIR] : 1               
                                          
                  Kappa : 0.2062          
                                          
 Mcnemar's Test P-Value : 1.12e-10        
                                          
            Sensitivity : 0.7778          
            Specificity : 0.5931          
         Pos Pred Value : 0.2625          
         Neg Pred Value : 0.9348          
             Prevalence : 0.1570          
         Detection Rate : 0.1221          
   Detection Prevalence : 0.4651          
      Balanced Accuracy : 0.6854          
                                          
       'Positive' Class : Yes

F_meas(pred, test.data$Attrition)

[1] 0.7257384

Not too bad. Specificity is just under the desired threshold.

fit.nb.02 <- train(Attrition ~ OverTime + MaritalStatus + StockOptionLevel, 
    data = nb.train.01, method = "naive_bayes", metric = "Spec", trControl = trnCtrl)
pred.02 <- predict(fit.nb.02, test.data)

confusionMatrix(pred.02, test.data$Attrition, positive = "Yes")

Confusion Matrix and Statistics

          Reference
Prediction  No Yes
       No  126  14
       Yes  19  13
                                          
               Accuracy : 0.8081          
                 95% CI : (0.7412, 0.8641)
    No Information Rate : 0.843           
    P-Value [Acc > NIR] : 0.9107          
                                          
                  Kappa : 0.3259          
                                          
 Mcnemar's Test P-Value : 0.4862          
                                          
            Sensitivity : 0.48148         
            Specificity : 0.86897         
         Pos Pred Value : 0.40625         
         Neg Pred Value : 0.90000         
             Prevalence : 0.15698         
         Detection Rate : 0.07558         
   Detection Prevalence : 0.18605         
      Balanced Accuracy : 0.67522         
                                          
       'Positive' Class : Yes

F_meas(pred.02, test.data$Attrition)

[1] 0.8842105

fit.nb.03 <- train(Attrition ~ OverTime + MaritalStatus + StockOptionLevel + 
    JobLevel, data = nb.train.01, method = "naive_bayes", metric = "Spec", trControl = trnCtrl)
pred.03 <- predict(fit.nb.03, test.data)

confusionMatrix(pred.03, test.data$Attrition, positive = "Yes")

Confusion Matrix and Statistics

          Reference
Prediction  No Yes
       No  101  10
       Yes  44  17
                                         
               Accuracy : 0.686          
                 95% CI : (0.611, 0.7545)
    No Information Rate : 0.843          
    P-Value [Acc > NIR] : 1              
                                         
                  Kappa : 0.2157         
                                         
 Mcnemar's Test P-Value : 7.098e-06      
                                         
            Sensitivity : 0.62963        
            Specificity : 0.69655        
         Pos Pred Value : 0.27869        
         Neg Pred Value : 0.90991        
             Prevalence : 0.15698        
         Detection Rate : 0.09884        
   Detection Prevalence : 0.35465        
      Balanced Accuracy : 0.66309        
                                         
       'Positive' Class : Yes

F_meas(pred.03, test.data$Attrition)

[1] 0.7890625

fit.nb.04 <- train(Attrition ~ OverTime + MaritalStatus + StockOptionLevel + 
    JobLevel + YearsInCurrentRole, data = nb.train.01, method = "naive_bayes", 
    metric = "Spec", trControl = trnCtrl)
pred.04 <- predict(fit.nb.04, test.data)

confusionMatrix(pred.04, test.data$Attrition, positive = "Yes")

Confusion Matrix and Statistics

          Reference
Prediction  No Yes
       No  107  11
       Yes  38  16
                                          
               Accuracy : 0.7151          
                 95% CI : (0.6414, 0.7812)
    No Information Rate : 0.843           
    P-Value [Acc > NIR] : 0.9999930       
                                          
                  Kappa : 0.2349          
                                          
 Mcnemar's Test P-Value : 0.0002038       
                                          
            Sensitivity : 0.59259         
            Specificity : 0.73793         
         Pos Pred Value : 0.29630         
         Neg Pred Value : 0.90678         
             Prevalence : 0.15698         
         Detection Rate : 0.09302         
   Detection Prevalence : 0.31395         
      Balanced Accuracy : 0.66526         
                                          
       'Positive' Class : Yes

F_meas(pred.04, test.data$Attrition)

[1] 0.8136882

nb.train.02 <- train.data %>% select(-c(colsToDrop))
fit.nb.05 <- train(Attrition ~ OverTime + MaritalStatus + StockOptionLevel + 
    JobLevel + YearsInCurrentRole + IncomeLt4000, data = nb.train.02, method = "naive_bayes", 
    metric = "Spec", trControl = trnCtrl)
pred.05 <- predict(fit.nb.05, test.data)

confusionMatrix(pred.05, test.data$Attrition, positive = "Yes")

Confusion Matrix and Statistics

          Reference
Prediction  No Yes
       No  106  12
       Yes  39  15
                                          
               Accuracy : 0.7035          
                 95% CI : (0.6292, 0.7706)
    No Information Rate : 0.843           
    P-Value [Acc > NIR] : 0.9999987       
                                          
                  Kappa : 0.2037          
                                          
 Mcnemar's Test P-Value : 0.0002719       
                                          
            Sensitivity : 0.55556         
            Specificity : 0.73103         
         Pos Pred Value : 0.27778         
         Neg Pred Value : 0.89831         
             Prevalence : 0.15698         
         Detection Rate : 0.08721         
   Detection Prevalence : 0.31395         
      Balanced Accuracy : 0.64330         
                                          
       'Positive' Class : Yes

F_meas(pred.05, test.data$Attrition)

[1] 0.8060837